home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / gnu / gawk / gawk213b.zoo / test / lisp / walk.w < prev   
Text File  |  1991-05-21  |  5KB  |  186 lines
  1. ; walk.w - extensions to simple interpreter in LISP
  2. ;
  3. ; Portions copyright (c) 1988, 1990 Roger Rohrbach
  4.  
  5. ; compositions of car, cdr
  6.  
  7. (set 'cadr '(lambda (e) (car (cdr e))))
  8. (set 'cddr '(lambda (e) (cdr (cdr e))))
  9. (set 'caar '(lambda (e) (car (car e))))
  10. (set 'cdar '(lambda (e) (cdr (car e))))
  11. (set 'cadar '(lambda (e) (car (cdr (car e)))))
  12. (set 'caddr '(lambda (e) (car (cdr (cdr e)))))
  13. (set 'cddar '(lambda (e) (cdr (cdr (car e)))))
  14. (set 'cdadr '(lambda (e) (cdr (car (cdr e)))))
  15.  
  16. ; basic predicates
  17.  
  18. (set 'null '(lambda (e) (eq e nil)))
  19. (set 'not '(lambda (e) (eq e nil)))
  20.  
  21. ; recursively defined functions
  22.  
  23. ; return the first atomic element of s
  24. (set 'ff
  25.     '(lambda (s)
  26.     (cond ((atom s) s) (t (ff (car s))))))
  27.  
  28. ; substitute x for all occurrences of the atom y in z
  29. (set 'subst
  30.     '(lambda (x y z)
  31.     (cond ((atom z) (cond ((eq z y) x) (t z)))
  32.         (t (cons (subst x y (car z)) (subst x y (cdr z)))))))
  33.  
  34. ; compare two s-expressions for equality
  35. (set 'equal
  36.     '(lambda (x y)
  37.     (or (and (atom x) (atom y) (eq x y))
  38.         (and (not (atom x))
  39.         (not (atom y))
  40.         (equal (car x) (car y))
  41.         (equal (cdr x) (cdr y))))))
  42.  
  43. ; create a new list containing the elements of x and y
  44. (set 'append
  45.     '(lambda (x y)
  46.     (cond ((null x) y)
  47.         (t (cons (car x) (append (cdr x) y))))))
  48.  
  49. ; McCarthy's `among' function (returns t or nil)
  50. (set 'member
  51.     '(lambda (x y)
  52.     (and (not (null y))
  53.         (or (equal x (car y)) (member x (cdr y))))))
  54.  
  55. ; pair the corresponding elements of two lists
  56. (set 'pair
  57.     '(lambda (x y)
  58.     (cond ((and (null x) (null y)) nil)
  59.         ((and (not (atom x)) (not (atom y)))
  60.         (cons (list (car x) (car y))
  61.             (pair (cdr x) (cdr y)))))))
  62.  
  63. ; association list selector function
  64. ; y is a list of the form ((u1 v1) ... (uN vN))
  65. ; x is one of the u's (an atom)
  66. ; here we return the pair (u v) as in most modern Lisps
  67. (set 'assoc
  68.     '(lambda (x y)
  69.     (cond ((null y) nil)
  70.         ((eq caar y x) (car y))
  71.         (t (assoc x (cdr y))))))
  72.  
  73. ; x is an association list
  74. ; (sublis x y) substitutes the values in x for the keys in y
  75. (set 'sublis
  76.     '(lambda (x y)
  77.     (cond ((atom y) (_sublis x y))
  78.         (t (cons (sublis x (car y)) (sublis x (cdr y)))))))
  79.  
  80. (set '_sublis
  81.     '(lambda (x z)
  82.     (cond ((null x) z)
  83.         ((eq (caar x) z) (cadar x))
  84.         (t (_sublis (cdr x) z)))))
  85.  
  86. ; return the last element of list e
  87. (set 'last
  88.     '(lambda (e)
  89.     (cond ((atom e) nil)
  90.         ((null (cdr e)) (car e))
  91.         (t (last (cdr e))))))
  92.  
  93. ; reverse a list
  94. (set 'reverse '(lambda (x) (_reverse x nil)))
  95. (set '_reverse
  96.     '(lambda (x y)
  97.     (cond ((null x) y)
  98.         (t (_reverse (cdr x) (cons (car x) y))))))
  99.  
  100. ; remove an element from a list
  101. (set 'remove
  102.     '(lambda (e l)
  103.     (cond ((null l) nil)
  104.         ((equal e (car l)) (remove e (cdr l)))
  105.         (t (cons (car l) (remove e (cdr l)))))))
  106.  
  107. ; find the successor of the atom x in y
  108. (set 'succ
  109.     '(lambda (x y)
  110.     (cond ((or (null y) (null (cdr y))) nil)
  111.         ((eq (car y) x) (cadr y))
  112.         (t (succ x (cdr y))))))
  113.  
  114. ; find the predecessor of the atom x in y
  115. (set 'pred
  116.     '(lambda (x y)
  117.     (cond ((or (null y) (null (cdr y))) nil)
  118.         ((eq (cadr y) x) (car y))
  119.         (t (pred x (cdr y))))))
  120.  
  121. ; return the elements in x up to y
  122. (set 'before
  123.     '(lambda (x y)
  124.     (cond ((atom x) nil)
  125.         ((null (cdr x)) nil)
  126.         ((equal (car x) y) nil)
  127.         ((equal (cadr x) y) (cons (car x) nil))
  128.         (t (cons (car x) (before (cdr x) y))))))
  129.  
  130. ; return the elements in x after y
  131. (set 'after
  132.     '(lambda (x y)
  133.     (cond ((atom x) nil)
  134.         ((equal (car x) y) (cdr x))
  135.         (t (after (cdr x) y)))))
  136.  
  137. ; return the property list of atom x
  138. (set 'plist '(lambda (x) (succ x Properties)))
  139.  
  140. ; get the value stored on x's property list under i
  141. (set 'get
  142.     '(lambda (x i)
  143.     ((lambda (pr)
  144.         (cond ((null pr) nil)
  145.         (t (cadr pr)))) (assoc i (plist x)))))
  146.  
  147. ; store v on x's property list under i
  148. (set 'putprop
  149.     '(lambda (x v i)
  150.     (and (or (plist x)
  151.         ; add a slot
  152.         (set 'Properties (cons x (cons nil Properties))))
  153.         (and (set 'Properties
  154.             (append (before Properties x)
  155.             (append
  156.                 (list x
  157.                 (cons (list i v)    ; new plist
  158.                     ((lambda (l)
  159.                     (remove (assoc i l) l)) (plist x))))
  160.                 (cdr (after Properties x))))) v))))
  161.  
  162. ; remove a property and value from x's plist
  163. (set 'remprop
  164.     '(lambda (x i)
  165.     (and (get x i)    ; if property exists
  166.         (set 'Properties
  167.         (append (before Properties x)
  168.             (append
  169.             (list x
  170.                 ((lambda (l)
  171.                 (remove (assoc i l) l)) (plist x)))
  172.             (cdr (after Properties x))))) i)))
  173.  
  174. ; map f onto each element of l, return the list of results
  175. (set 'mapcar
  176.     '(lambda (f l)
  177.     (cond ((null l) nil)
  178.         (t (cons (eval (list f (list 'quote (car l))))
  179.         (mapcar f (cdr l)))))))
  180.  
  181. ; call f with args, i.e., (apply 'cons '(a (b))) <-> (cons 'a '(b))
  182. (set 'apply
  183.     '(lambda (f args)
  184.     (cond ((null args) nil)
  185.     (t (eval (cons f (mapcar '(lambda (a) (list 'quote a)) args)))))))
  186.